home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / SIOD / Sort.scm < prev    next >
Text File  |  1993-09-25  |  2KB  |  44 lines
  1. (define (sort! x . y)
  2.         (define test <=)
  3.         (define (interchange x i j)
  4.                 (let ((tmp (vector-ref x i)))
  5.                      (vector-set! x i (vector-ref x j))
  6.                      (vector-set! x j tmp)))
  7.         (define (qsort x m n)
  8.                 (if (< m n)
  9.                     (do ((i m) (j (1+ n))
  10.                          (k (begin (interchange x m (quotient (+ m n) 2))  
  11.                                    (vector-ref x m))))
  12.                         ((>= i j) (interchange x m j)
  13.                                   (qsort x m (-1+ j))
  14.                                   (qsort x (1+ j) n) x)
  15.                         (set! i (1+ i))
  16.                         (while (and (test (vector-ref x i) k) (< i n))
  17.                                (set! i (1+ i)))
  18.                         (set! j (-1+ j))
  19.                         (while (and (test k (vector-ref x j)) (> j m))
  20.                                (set! j (-1+ j)))
  21.                         (when (< i j) (interchange x i j)))))
  22.         (define (merge-list x y)
  23.                 (cond ((null? x) y)
  24.                       ((null? y) x) 
  25.                       (else (if (test (car x) (car y))
  26.                                 (cons (car x) (merge-list (cdr x) y))
  27.                                 (cons (car y) (merge-list x (cdr y)))))))
  28.         (define (merge-sort x)
  29.                 (if (null? x)
  30.                     nil
  31.                     (do ((ptr1 x (cdr ptr1))
  32.                          (ptr2 (cdr x) (cdr ptr2)))
  33.                         ((or (null? ptr2) 
  34.                              (test (car ptr2) (car ptr1))) 
  35.                          (set-cdr! ptr1 nil)
  36.                          (merge-list x (merge-sort ptr2))))))
  37.         (when (pair? y)
  38.               (if (proc? (car y))
  39.                   (set! test (car y))
  40.                   (error "second arg to sort! must be a procedure" (car y))))
  41.         (cond ((vector? x) (qsort x 0 (-1+ (vector-length x))) x)
  42.               ((pair? x) (merge-sort x))
  43.               (else (error "first arg to sort! must be a vector or a list" x))))
  44.